home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol218 / alphaper.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1986-11-30  |  5.1 KB  |  177 lines
  1. 100  REM ALPHAPER Program.
  2. 110  REM Prints an Alphabetic List of Persons
  3. 120  REM By:  Melvin O. Duke.  Last Updated 17 February 1986.
  4. 200  REM Screen Definitions
  5. 210  WIDTH "scrn:", 80
  6. 220  SCREEN S1,S2,S3,S4
  7. 600  REM Titles
  8. 610  TITLE$ = "Alphabetic Person Name Listing"
  9. 620  TITLE$ = TITLE$ + " ON DISPLAY"
  10. 700  REM Terminate if not called from the Menu
  11. 710  IF DD.MENU$ <> "" THEN 770
  12. 720  COLOR 7,0 : KEY ON : CLS : LOCATE 15,1
  13. 730  PRINT "Cannot run the"
  14. 740  PRINT TITLE$
  15. 750  PRINT "Program, unless selected from the MENU"
  16. 760  END
  17. 770  REM OK
  18. 900  REM Dimension Statements
  19. 910  DIM IDX$(MAX.PER), WHERE(MAX.PER)
  20. 1000  REM Produce the first screen
  21. 1010  KEY ON : CLS : KEY OFF
  22. 1020  REM Draw the outer double box
  23. 1030  R1 = 1 : C1 = 1 : R2 = 24 : C2 = 79 : GOSUB 1300
  24. 1040  REM Find the title location
  25. 1050  TITLE.POS = 40 - INT(LEN(TITLE$)/2)
  26. 1060  REM Draw the title box
  27. 1070  R1=3:C1=TITLE.POS-2:R2=6:C2=TITLE.POS+LEN(TITLE$)+1:GOSUB 1500
  28. 1080  REM Print the title
  29. 1090  LOCATE 4,TITLE.POS : PRINT TITLE$
  30. 1100  LOCATE 5,40-INT(LEN(VERSION$)/2) :  PRINT VERSION$;
  31. 1230  REM Draw the Copyright box
  32. 1240  R1 = 19 : C1 = 21 : R2 = 22 : C2 = 59 : GOSUB 1300
  33. 1250  REM Print the Copyright
  34. 1260  LOCATE 20,40-INT(LEN(COPY1$)/2) :  PRINT COPY1$;
  35. 1270  LOCATE 21,40-INT(LEN(COPY2$)/2) :  PRINT COPY2$;
  36. 1280  GOTO 1700
  37. 1300  REM subroutine to print a double box
  38. 1310  COLOR P
  39. 1320  FOR I = R1 + 1 TO R2 - 1
  40. 1330   LOCATE I, C1 : PRINT CHR$(186);
  41. 1340   LOCATE I, C2 : PRINT CHR$(186);
  42. 1350  NEXT I
  43. 1360  FOR J = C1 + 1 TO C2 - 1
  44. 1370   LOCATE R1, J : PRINT CHR$(205);
  45. 1380   LOCATE R2, J : PRINT CHR$(205);
  46. 1390  NEXT J
  47. 1400   LOCATE R1, C1 : PRINT CHR$(201);
  48. 1410   LOCATE R1, C2 : PRINT CHR$(187);
  49. 1420   LOCATE R2, C1 : PRINT CHR$(200);
  50. 1430   LOCATE R2, C2 : PRINT CHR$(188);
  51. 1440  COLOR W
  52. 1450  RETURN
  53. 1500  REM subroutine to print a single box
  54. 1510  COLOR B
  55. 1520  FOR I = R1 + 1 TO R2 - 1
  56. 1530   LOCATE I, C1 : PRINT CHR$(179);
  57. 1540   LOCATE I, C2 : PRINT CHR$(179);
  58. 1550  NEXT I
  59. 1560  FOR J = C1 + 1 TO C2 - 1
  60. 1570   LOCATE R1, J : PRINT CHR$(196);
  61. 1580   LOCATE R2, J : PRINT CHR$(196);
  62. 1590  NEXT J
  63. 1600   LOCATE R1, C1 : PRINT CHR$(218);
  64. 1610   LOCATE R1, C2 : PRINT CHR$(191);
  65. 1620   LOCATE R2, C1 : PRINT CHR$(192);
  66. 1630   LOCATE R2, C2 : PRINT CHR$(217);
  67. 1640  COLOR W
  68. 1650  RETURN
  69. 1700  REM ask user to press a key to continue
  70. 1710  LOCATE 25,1
  71. 1720  PRINT "Have Data Diskette(s) in Place, then Press any key to continue.";
  72. 1730  K$ = INKEY$ : IF K$ = "" THEN 1730
  73. 1740  KEY ON : CLS : KEY OFF
  74. 2000  REM ALPHAPER Program Starts Here.
  75. 2010  OPEN DD.PERS$+"persfile" AS #1 LEN = 256
  76. 2020  FIELD 1, 5 AS F1$, 20 AS F2$, 30 AS F3$, 2 AS F4$, 5 AS F5$, 5 AS F6$, 5 AS F7$, 11 AS F8$, 18 AS F9$, 16 AS F10$, 16 AS F11$, 11 AS F12$, 18 AS F13$, 16 AS F14$, 16 AS F15$, 11 AS F16$, 18 AS F17$, 16 AS F18$, 16 AS F19$
  77. 2030  KEY ON : CLS : KEY OFF
  78. 2040  REM Read all records, and print the actual ones
  79. 2050  N.ACT = 1
  80. 2060  FOR I = 1 TO MAX.PER
  81. 2070  GET #1, I
  82. 2080  LOCATE 23,1 : PRINT "Processing Record:";I,"Freespace:";FRE(0)
  83. 2090  REM Extract Information from the File
  84. 2100   WHERE(N.ACT) = CVS(F1$)
  85. 2110   IF WHERE(N.ACT) < 1 THEN 2400
  86. 2120   T2$ = F2$  'Surname
  87. 2130   REM Right-trim t2$
  88. 2140   FOR J = 1 TO LEN(F2$)-1
  89. 2150    IF RIGHT$(T2$,1)=" "THEN T2$=LEFT$(T2$,LEN(T2$)-1) ELSE J=LEN(F2$)-1
  90. 2160   NEXT J
  91. 2170   T3$ = F3$  'Given Names
  92. 2180   REM Right-trim t3$
  93. 2190   FOR J = 1 TO LEN(F3$)-1
  94. 2200    IF RIGHT$(T3$,1)=" "THEN T3$=LEFT$(T3$,LEN(T3$)-1) ELSE J=LEN(F3$)-1
  95. 2210   NEXT J
  96. 2220   T8$ = F8$  'Birthdate
  97. 2230   REM convert to yyyymmdd
  98. 2240   TEMP$ = RIGHT$(T8$,4)
  99. 2250   IF MID$(T8$,4,3)="Jan" THEN TEMP$=TEMP$+"01"
  100. 2260   IF MID$(T8$,4,3)="Feb" THEN TEMP$=TEMP$+"02"
  101. 2270   IF MID$(T8$,4,3)="Mar" THEN TEMP$=TEMP$+"03"
  102. 2280   IF MID$(T8$,4,3)="Apr" THEN TEMP$=TEMP$+"04"
  103. 2290   IF MID$(T8$,4,3)="May" THEN TEMP$=TEMP$+"05"
  104. 2300   IF MID$(T8$,4,3)="Jun" THEN TEMP$=TEMP$+"06"
  105. 2310   IF MID$(T8$,4,3)="Jul" THEN TEMP$=TEMP$+"07"
  106. 2320   IF MID$(T8$,4,3)="Aug" THEN TEMP$=TEMP$+"08"
  107. 2330   IF MID$(T8$,4,3)="Sep" THEN TEMP$=TEMP$+"09"
  108. 2340   IF MID$(T8$,4,3)="Oct" THEN TEMP$=TEMP$+"10"
  109. 2350   IF MID$(T8$,4,3)="Nov" THEN TEMP$=TEMP$+"11"
  110. 2360   IF MID$(T8$,4,3)="Dec" THEN TEMP$=TEMP$+"12"
  111. 2370   TEMP$=TEMP$+LEFT$(T8$,2)  'add day
  112. 2380   IDX$(N.ACT) = T2$+" "+T3$+TEMP$
  113. 2390   N.ACT = N.ACT + 1
  114. 2400  NEXT I
  115. 2410  N.ACT = N.ACT - 1
  116. 2420  LOCATE 23,1 : PRINT SPACE$(79)
  117. 2430  REM Sort the index into ascending sequence
  118. 2440  KEY ON : CLS : KEY OFF
  119. 2450  FOR I = 1 TO 6
  120. 2460   B(I) = B(I-1)*4+1
  121. 2470   IF B(I) <= N.ACT/2 THEN K1 = I
  122. 2480  NEXT I
  123. 2490  B(K1) = INT(N.ACT/5) +1
  124. 2500  B(1) = 1
  125. 2510  LOCATE 21,1 : PRINT "Total Records:";N.ACT;
  126. 2520  FOR I = K1 TO 1 STEP -1
  127. 2530   LOCATE 23,1 : PRINT "Sorting Group:";I
  128. 2540   K1 = B(I)
  129. 2550   FOR J = K1 TO N.ACT
  130. 2560    LOCATE 23,20 : PRINT "J:";J;
  131. 2570    K2$ = IDX$(J) : K3 = WHERE(J)
  132. 2580    FOR K = J-K1 TO 0 STEP -K1
  133. 2590     LOCATE 23,30 : PRINT "K:";K,"Freespace:";FRE(0)
  134. 2600     IF K2$ >= IDX$(K) THEN 2630
  135. 2610     IDX$(K+K1) = IDX$(K) : WHERE(K+K1) = WHERE(K)
  136. 2620    NEXT K
  137. 2630    IDX$(K+K1) = K2$ : WHERE(K+K1) = K3
  138. 2640   NEXT J
  139. 2650  NEXT I
  140. 2660  LOCATE 24,1 : PRINT SPACE$(79);
  141. 2670  LOCATE 23,1 : PRINT SPACE$(79);
  142. 2680  LOCATE 23,1 : PRINT "Printing the Alphabetical List"
  143. 2690  GOSUB 2710
  144. 2700  GOTO 2760
  145. 2710  LPRINT "     Alphabetic Listing of the Persons File   ";DATE$;"  ";TIME$
  146. 2720  LPRINT
  147. 2730  LPRINT "  REC    SURNAME              GIVEN-NAMES";TAB(62);"BIRTHDATE"
  148. 2740  LPRINT "  ---    -------              -----------";TAB(62);"---------"
  149. 2750  RETURN
  150. 2760  REM Read all records, and print the actual ones
  151. 2770  K = 0
  152. 2780  KEY ON : CLS : KEY OFF
  153. 2790  LOCATE 21,1 : PRINT "There are";N.ACT;"records."
  154. 2800  FOR I = 1 TO N.ACT
  155. 2810   GET #1, ABS(WHERE(I))
  156. 2820   LOCATE 23,1 : PRINT "Printing Record:"; I, "Freespace:";FRE(0)
  157. 2830   REM Print the information in Alphabetical Order.
  158. 2840   T1 = CVS(F1$)
  159. 2850   IF T1 < 1 THEN 2930
  160. 2860   K = K + 1
  161. 2870   T2$ = F2$
  162. 2880   T3$ = F3$
  163. 2890   T8$ = F8$
  164. 2900   IF K MOD 55 = 0 THEN LPRINT FORM.FEED$;: GOSUB 2710
  165. 2910   LPRINT USING "#####";T1,
  166. 2920   LPRINT TAB(10); T2$; " "; T3$; TAB(62); T8$
  167. 2930  NEXT I
  168. 2940  LPRINT FORM.FEED$;
  169. 2950  KEY ON : CLS : KEY OFF
  170. 2960  LOCATE 24,1 : PRINT "y (yes) or n (no)";
  171. 2970  LOCATE 23,1 : INPUT "Would you like another copy"; REPLY$
  172. 2980  IF LEFT$(REPLY$,1) = "y" OR LEFT$(REPLY$,1) = "Y" THEN 2660
  173. 2990  CLOSE #1
  174. 3000  KEY ON : CLS : KEY OFF : LOCATE 21,1
  175. 3010  PRINT "End of Program"
  176. 3020  RUN DD.MENU$+"menu"
  177.